perm filename MARKZ.F4[NEW,LCS]7 blob
sn#539623 filedate 1980-10-03 generic text, type T, neo UTF8
00100 C**** MARKZ -- XREAD (FOR MARKZ,SLURZ) -- ZNOTE -- MARKS
00200
00300 SUBROUTINE MARKZ
00400 COMMON /XRN/RN(1)
00500 1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
00600 1 NOSET,STEM,STUP,NTC,PS2,RAM,RDD,IT,POS /ALF/INP(72),ML
00700 1 /LIMIT/LIMIT,ITEM,LL,IS,IX /MX/MX,MZ
00800 1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
00900 1 /SCX/JALPHA(7),ISTAR,JAL(22),JX,U,JZ,IRHY,JD,KA,KB,IZ
01000 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
01100 1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
01200
01300 INVT=-1
01400 MX=0
01500 JNTC=NTC-1
01600 C JNTC=NUM OF NTS NOW
01700 JREP=-1
01800 C JREP IS FOR REPEAT FEATURE IN 'MARKS'
01900 25 CALL XREAD
02000 IF(VX(1).EQ.0)CALL NEWMRK(VX,MX)
02100 C ABOVE FOR NEW MARKS INPUT FORMAT.
02200 505 L=0
02300 K=0
02400 POS=-10.
02500 5032 IF(N.LE.JNTC)GO TO 5030
02600 N=JNTC
02700 C TRAPS ERROR OF TRYING TO PUT MARK ON NON-EXISTENT NOTE.
02800 VX(J)=N
02900 C VX(J)=N IS NEEDED AT LABEL 130
03000 5030 L=L+1
03100 502 K=K+1
03200 IF(R(1,K).NE.1.)GO TO 502
03300 C IS IT A NOTE?
03400 P=R(3,K)
03500 IF(P.EQ.POS)GO TO 502
03600 C SKIPS DBLSTPS
03700 POS=P
03800 506 IF(L.LT.N)GO TO 5030
03900 30 IF(JREP)CALL MARKS(RA)
04000 RB=0
04100 J=J+1
04200 CXXX IF(RA.GE.30.AND.RA.LE.35)VX(J+1)=0
04300 C THIS ↑↑↑↑ CATCHES FINGERING NUM.(0-5) IT WAS READ IN MARKS.
04400 IF(RA.EQ.99)RA=VX(J)
04500 C IF STEM IS DOWN OR THERE ARE NOTES BELOW(DBL STP), POSITION
04600 C OF ACCENT WILL BE INVERTED.
04700 130 IF(RA.LT.37)GO TO 304
04800 C 37=RIT.
04900 C=POSIT(VX(J-1))
05000
05100 IF(RA.LE.60.OR.RA.GT.63)GO TO 308
05200 C NEXT FOR TREMOLO: TM, TME, TMS, =32ND, 8TH, 16TH
05300 NN=11
05400 A=8
05500 C A IS WDCNT-2
05600 B=6
05700 C CODE NUM. IS IN B
05800 CXCX C=C+1.5
05900 C FIND POSITION OF THIS NOTE
06000 BB=R(4,K)
06100 C BB=HEIGHT
06200 RC=AMOD(R(7,K),10.0)
06300 C LOOK FOR TAILS
06400 X=0
06500 IF(RA.EQ.61)X=1
06600 C RA=61= 8TH NOTE BEAM
06700 AA=R(8,K)
06800 C TREM. POS. WILL DEPEND ON NOTE POS. AND STEM LENGTH
06900 IF(AA.NE.0)GO TO 2309
07000 AA=1-X
07100 R(8,K)=1.2-X
07200 2309 AA=AA-1
07300 C AA = AMOUNT TO BE ADDED OR SUBTRACTED WITH HEIGHT OF NOTE
07400 IF(R(5,K).GE.20)GO TO 1309
07500 C CHECK ON STEM DIRECTION
07600 X=-(RA-50)
07700 C MAKES -11, -12, -13, ETC.
07800 IF(RC.NE.0)BB=BB-2
07900 GO TO 309
08000 1309 X=-(RA-40)
08100 C MAKES -21, -22, ETC.
08200 AA=-AA
08300 IF(RC.NE.0)BB=BB+2
08400 309 BB=BB+AA
08500 C OK FOR 16TH AND 32ND - BUT 8TH NEEDS MORE WORK******
08600 RC=0
08700 RN(IS+9)=0
08800 RN(IS+10)=0
08900 C ABOVE IS TO LEAVE ROOM FOR CHANGE OF TREM TO BE PARALLEL TO OTHER BM.
09000 GO TO 305
09100
09200 308 IF(RA.LT.100)C=C-1.5
09300 C '-1.5' PUSHES IT TO LEFT. MAYBE CHANGE ORIGINAL POSITIONS??
09400 NN=6
09500 RC=RA
09600 BB=-6
09700 A=3
09800 B=3
09900 IF(XNOTE(K).LT.3)BB=XNOTE(K)-7.5
10000 C LOWERS ITEM IF NOTE BELOW STAFF. BUT IS 'K' ALWAYS OK HERE??????
10100 IF(RA.LT.99)GO TO 305
10200 C NEXT FOR CRESC. & DECRSC. LINES<,>. TYPE /NT1 C+ NT2/ OR /N1.d C- N2.d/
10300 C ALSO FOR "8va ----" /NT1 O NT2/
10400 NN=8
10500 BB=BB+2.5
10600 A=5
10700 B=4
10800 RB=50
10900 IF(RA.NE.208)GO TO 306
11000 RB=0
11100 B=7
11200 BB=15
11300 C LATER ADD CHECK FOR HEIGHT OF NOTES UNDER 8va.
11400 306 X=RA-200
11500 C MAKES ZERO OR -1 OR 8 IN P7
11600 RC=RB
11700 C ADDS A NEW ITEM. MP, PP, CRESC., ETC. --CODE 3
11800 305 CALL RNX(A,B,STAFF,C,BB,RC,0,X,0)
11900 C RNX FILLS PARAMS 0→8
12000 IS=IS+NN
12100 IF(B.EQ.3.OR.B.EQ.6)GO TO 230
12200 C B=6=TREM. NN=6=WORDS OR LTRS. UNDER STAFF.
12300 1 J=J+1
12400 IF(VX(J).EQ.0)GO TO 1
12500 C ABOVE FOR NEW MARKS FORMAT. (I HOPE IT'S COMPATIBLE WITH OLD!)
12600 RC=POSIT(VX(J))
12700 IF(RB.EQ.0)RC=RC+3
12800 C RB=0= 8va
12900 RN(IS-2)=RC
13000 C THIS IS P6 (POS2 FOR CRESC. LINES)
13100 514 J=J+1
13200 A=VX(J)
13300 N=A
13400 C SO ITEMS NEED NOT BE IN RIGHT ORDER.
13500 IF(MOD(N,100).GT.IRHY)A=0
13600 IF(A.NE.0)GO TO 505
13700 CC***USE NO NUMBS IN COMMENTS IN MODE 3-5****** IF(VX(J+2).EQ.0)GO TO 614
13800 IF(J.LT.50)GO TO 514
13900 C SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
14000 614 IF(INP(72).NE.ISTAR)GO TO 552
14100
14200 714 IF(INVT)RETURN
14300 INVT=IS
14400 CALL NEWR
14500 IS=INVT
14600 RETURN
14700 552 IF(MX.EQ.0)GO TO 553
14800 C GO GET REST OF LINE THAT WAS TOO LONG FOR NEW FORMAT
14900 CALL MORMRK(MX,MZ,VX)
15000 J=1
15100 MX=0
15200 CC INP(72)='*'
15300 GO TO 505
15400 553 CALL BMREAD
15500 C TO READ MORE THAN 2 LINES.
15600 GO TO 25
15700
15800
15900 304 RB=R(2,K)
16000 IF(RA.EQ.6)RA=26.
16100 A=RA
16200 IF(RB.EQ.0)GO TO 301
16300 IF(RB.GE.10)GO TO 303
16400 A=A*100
16500 GO TO 301
16600 303 RB=RB*100
16700 301 R(2,K)=RB+A
16800 C P11 INFO(MARKS) IS TEMPORARILY STORED IN P2 (STAFF# IS IN STAFF)
16900 230 A=VX(J)
17000 JREP=-1
17100 IF(A.EQ.0)GO TO 514
17200 C NEXT FOR STRING OF SAME MARK ( /3 12 S/ )
17300 IF(A.GT.JNTC)A=JNTC
17400 C WON'T PUT MARK BEYOND LAST NOTE
17500 JREP=0
17600 J=J-1
17700 VX(J)=VX(J)+1
17800 IF(VX(J).GE.A)VX(J+1)=0
17900 J=J-1
18000 GO TO 514
18100 C USES 4-7,9,11-13 FOR ACC. > FERM. DOT - DNBOW UPBOW HARM.
18200 C NOTE#,ACCENT#/N,A/N,A*
18300 END
18400
18500
18600 SUBROUTINE XREAD
18700 COMMON /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72)
18800 1 /SCX/JALPHA(7),ISTAR,JAL(22),JX,U,JZ,IRHY,JD,KA,KB,IZ
18900 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
19000 1 ,JXX,ISEMI,IQT,VX(50),IAMP,K
19100 1 /A2Z/IAZ(5),LEF
19200 DO 1500 K=1,72
19300 J=INP(K)
19400 IF(J.NE.LEF)GO TO 1
19500 CHECK TO SEE IF A NUMBER FOLLOWS 'F' (FINGERING)(F0=FU F5=FZ)
19600 L=INP(K+1)
19700 IF(ISNUM(L).LT.0)GO TO 1
19800 INP(K+1)=IAZ(NALF(L)+21)
19900 1 IF(J.EQ.ISTAR)GO TO 15
20000 1500 IF(J.EQ.ISEMI)GO TO 500
20100 15 INP(72)=ISTAR
20200 C ABOVE FOR 2ND LNE OF INPUT. IF LNS ENDS WITHOUT * OR ;, IT PUTS IN *
20300 C ******* 1ST MAIN LOOP *********
20400 CXCX 500 REREAD F78F,VX
20500 500 CALL RREAD(INP,VX)
20600 CC J=0
20700 CC IF(IREAD.EQ.-1)J=1
20800 C SKIPS LINE #S IN SOS FILES. (=-2 IS FOR ET FILES.)
20900 CC J=J+1
21000 J=1
21100 N=VX(1)
21200 END
21300
21400 FUNCTION ZNOTE(K)
21500 C ADJUSTS HEIGHT IN RE. TO STAFF ABOVE OR BELOW AND SPECIFIED STEM DIR.
21600 COMMON /SCX/JALPHA(30),X /RINP/R(10,85)
21700 1 /RMOD/RMODE2,SET4,IBEAM,NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM
21800 ZNOTE=XNOTE(K)
21900 IF(JSTEM.GT.K)RETURN
22000 L=R(10,K)
22100 IF(L.EQ.0)RETURN
22200 M=X/10.
22300 IF(M.EQ.0)RETURN
22400 IF(M.EQ.L)RETURN
22500 M=R(5,K)/10.
22600 C ASSUMES SPECIFIED STEM DIR. IS CORRECT
22700 A=0
22800 IF(L.EQ.1)GO TO 1
22900 IF(M.EQ.2)A=-14.
23000 GO TO 2
23100 1 IF(M.EQ.1)A=14.
23200 2 ZNOTE=ZNOTE+A
23300 END
23400
23500 SUBROUTINE MARKS(RA)
23600 COMMON/ALF/INP(72),ML /JCHAR/IXX,ISEMX,IBLA
23700 1 /MKS/MKS(14) /MKX/KSLA,ISEMI,NONO(7),MINUS,ISTAR
23800 1 /A2Z/A1(4),LEE,A2(6),LEL,LMM,LNN,A3(6),LEU,LV,LW,LX,LY,LEZ
23900 1 /SCX/ICOM,MINU,IDOT,IEQ,LPRN,IRPRN,IPLUS
24000 1 /SC/J,NO(15),VX(50)
24100 EQUIVALENCE (MF,MKS(3)),(MH,MKS(9)),(MP,MKS(11)),(MM,MKS(5))
24200 1,(MC,MKS(12)),(MR,MKS(13)),(MI,MKS(10)),(MS,MKS(4))
24300 1,(MO,MKS(14)),(MW,MKS(1))
24400 RA=99
24500 DO 16 JM=1,72
24600 16 IF(INP(JM))GO TO 17
24700 C DIDN'T FIND MORE LETTERS
24800 RETURN
24900 17 N=INP(JM)
25000 ML=INP(JM+1)
25100 M=INP(JM+2)
25200 DO 1 K=1,14
25300 1 IF(N.EQ.MKS(K))GO TO 2
25400 C DID NOT FIND A LETTER
25500 RETURN
25600 C 4=W(EDGE),5=A(CCENT),26=FE(RMATA),7=S(TACCATO),9=T(ENUTO)
25700 C 11=D(OWNBOW), 12=U(PBOW),13=H(ARMONIC),14=PL(US),15=TH(ESIS)
25800 C 16=AR(SIS),17=MO(RDANT)
25900 C 18=I(NVRTD MORD), ---,20=TR(ILL), 21=TRF(LAT), 22=TRS(HARP)
26000 C 23=TRN(ATURAL), >39=PPP, PP, CRESC., ETC.
26100 C 25=HW (HEAVY WEDGE), 80=ACC(EL.) FICTA:5=FLAT, 2=#, 3=NAT.
26200 C 27=TS(TEN.+STAC.) 28=WS(WEDGE+STAC.) 29=AS(ACCENT+STACCATO)
26300 2 GO TO(220,10,12,120,4,11,15,15,15,21,12,80,81,87),K
26400 12 IF(ML.EQ.LEL)GO TO 320
26500 C ↑↑↑ PLUS
26600 IF(N.EQ.MF)GO TO 121
26700 RA=42
26800 IF(ML.NE.MP)GO TO 18
26900 RA=41
27000 IF(M.EQ.MP)RA=40
27100 C FOR P, PP, PPP -- 42, 41, 40
27200 GO TO 18
27300 220 IF(ML.EQ.MS)K=25
27400 C 'WS' = WEDGE+STACCATO =28
27500 GO TO 320
27600 15 IF(ML.EQ.MI)GO TO 82
27700 K=K+1
27800 IF(ML.EQ.MW)K=22
27900 C 'HW' MAKES 25 (EVENTUALLY MAKES CLEF# 44)
28000 120 IF(ML.EQ.MF)GO TO 88
28100 320 K=K+3
28200 8 RA=K
28300 C YOU CAN TYPE # OR NAME OF MARK
28400 18 DO 6 JM=1,72
28500 N=INP(JM)
28600 INP(JM)=IBLA
28700 C BLANKS OUT USED LETTERS
28800 IF(N.EQ.KSLA)RETURN
28900 IF(N.EQ.ISTAR)RETURN
29000 6 IF(N.EQ.ISEMI)RETURN
29100 4 IF(ML.EQ.MO)GO TO 20
29200 RA=43
29300 IF(ML.EQ.MF)RA=50
29400 C ↑↑↑↑↑ MP, MF
29500 GO TO 18
29600 121 IF(ML.EQ.LEE)GO TO 320
29700 C ↑↑↑ FERMATA
29800 RA=51
29900 IF(ML.EQ.MF)RA=52
30000 IF(ML.EQ.MP)RA=54
30100 IF(M.EQ.MF)RA=53
30200 C F, FF, FFF, FP -- 51, 52, 53, 54 --- SF=45, SFZ=92
30300 IF(ML.NE.MI)GO TO 22
30400 C TYPE FIF, FIS, FIN FOR FICTA flat, sharp, natural
30500 RA=1
30600 IF(M.EQ.MS)RA=2
30700 IF(M.EQ.LNN)RA=3
30800 GO TO 18
30900 22 IF(ML.GE.LEU.AND.ML.LE.LEZ)RA=30+(ML-LEU)/536870912
31000 C TYPE /2 F0/6 F5/ FOR FINGERING NUMS. 0-5 FU=F0, FZ=F5
31100 GO TO 18
31200 88 RA=45
31300 C FOR SF AND SFZ
31400 IF(INP(JM+2).EQ.LZZ)RA=92
31500 GO TO 18
31600 10 IF(ML.EQ.MC)GO TO 84
31700 C 'AC'=ACCEL.
31800 IF(ML.EQ.MR)K=13
31900 C 'AR' FOR ARSIS
32000 IF(ML.EQ.MS)K=26
32100 C 'AS'=ACCENT-STACCATO COMBO (=29)
32200 GO TO 320
32300 11 IF(ML.EQ.MH)K=12
32400 C THESIS
32500 IF(ML.NE.MM)GO TO 110
32600 K=60
32700 IF(M.EQ.LEE)K=58
32800 IF(M.EQ.MS)K=59
32900 C TM=TREMOLO,3 BEAMS=63 AT LABEL 8
33000 C TME, TMS: 61=1 BEAM, 62=2 BEAMS
33100 110 IF(ML.NE.MR)GO TO 111
33200 K=17
33300 C TR(ILL)=20 TRF(LAT)=21 TRS(HARP)=22 TRN(ATRL)=23
33400 IF(M.EQ.MF)K=18
33500 IF(M.EQ.MS)K=19
33600 IF(M.EQ.LNN)K=20
33700 GO TO 320
33800 111 IF(ML.EQ.MS)K=24
33900 C TS=TEN.+STAC.=27
34000 GO TO 320
34100 20 K=17
34200 GO TO 8
34300 21 K=18
34400 GO TO 8
34500 CC80 IF(ML.EQ.IPLUS)GO TO 85
34600 CC IF(ML.EQ.MINUS)GO TO 86
34700 C FOR /N1 C+ N2/ ETC. -- CRESC. AND DECRESC. LINES.
34800 C '+' IS OPTIONAL. 2ND NUM. MEANS NOT 'CRESC.'
34900 80 IF(ML.EQ.MINUS)GO TO 86
35000 IF(ML.NE.MR)GO TO 85
35100 CRR***CX IF(ML.NE.MR)GO TO 85
35200 CRR*** IF(VX(J+2).NE.0)GO TO 85
35300 RA=70
35400 C 'CR'='CRESC.'
35500 GO TO 18
35600 85 RA=200
35700 GO TO 18
35800 86 RA=199
35900 GO TO 18
36000 87 RA=208
36100 GO TO 18
36200 C ↑↑↑ FOR /N1 OT N2/ 8va
36300 81 RA=37
36400 C RIT.
36500 GO TO 18
36600 82 RA=82
36700 C DIM.
36800 GO TO 18
36900 84 RA=80
37000 C ACCEL.
37100 GO TO 18
37200 END